home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / lispm-fonts.el.z / lispm-fonts.el
Encoding:
Text File  |  1998-05-21  |  6.4 KB  |  192 lines
  1. ;;; lispm-fonts.el --- quick hack to parse LISPM-style font-shift codes
  2.  
  3. ;; Keywords: faces
  4.  
  5. ;; Copyright (C) 1992-1993 Free Software Foundation, Inc.
  6.  
  7. ;; This file is part of XEmacs.
  8.  
  9. ;; XEmacs is free software; you can redistribute it and/or modify it
  10. ;; under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; XEmacs is distributed in the hope that it will be useful, but
  15. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. ;; General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Synched up with: Not in FSF.
  25.  
  26. ;; This only copes with MIT/LMI/TI style font shifts, not Symbolics.
  27. ;; It doesn't do diagram lines (ha ha).  It doesn't do output.  That
  28. ;; has to wait until it is possible to attach faces to characters
  29. ;; instead of just intervals, since this code is really talking about
  30. ;; attributes of the text instead of attributes of regions of the
  31. ;; buffer.  We could do it by mapping over the extents and hacking
  32. ;; the overlaps by hand, but that would be hard.
  33.  
  34. (make-face 'variable)
  35. (or (face-differs-from-default-p 'variable)
  36.     (set-face-font 'variable
  37.            "-*-helvetica-medium-r-*-*-*-120-*-*-*-*-*-*"))
  38.  
  39. (make-face 'variable-bold)
  40. (or (face-differs-from-default-p 'variable-bold)
  41.     (progn
  42.       ;; This is no good because helvetica-12-bold is a LOT larger than
  43.       ;; helvetica-12-medium.  Someone really blew it there.
  44.       ;; (copy-face 'variable 'variable-bold)
  45.       ;; (make-face-bold 'variable-bold)
  46.       (set-face-font 'variable-bold
  47.              "-*-helvetica-bold-r-*-*-*-100-*-*-*-*-*-*")))
  48.  
  49. (make-face 'variable-italic)
  50. (or (face-differs-from-default-p 'variable-italic)
  51.     (progn
  52.       (copy-face 'variable-bold 'variable-italic) ; see above
  53.       (make-face-unbold 'variable-italic)
  54.       (make-face-italic 'variable-italic)))
  55.  
  56. (make-face 'variable-bold-italic)
  57. (or (face-differs-from-default-p 'variable-bold-italic)
  58.     (progn
  59.       (copy-face 'variable-bold 'variable-bold-italic)
  60.       (make-face-italic 'variable-bold-italic)))
  61.  
  62. (defconst lispm-font-to-face
  63.   '(("tvfont"        . default)
  64.     ("cptfont"        . default)
  65.     ("cptfontb"        . bold)
  66.     ("cptfonti"        . italic)
  67.     ("cptfontbi"    . bold-italic)
  68.     ("base-font"    . default)
  69.     ("bigfnt"        . bold)
  70.     ("cmb8"        . variable-bold)
  71.     ("higher-medfnb"    . bold)
  72.     ("higher-tr8"    . default)
  73.     ("medfnb"        . bold)
  74.     ("medfnt"        . normal)
  75.     ("medfntb"        . bold)
  76.     ("wider-font"    . bold)
  77.     ("wider-medfnt"    . bold)
  78.     ("mets"        . variable-large)
  79.     ("metsb"        . variable-large-bold)
  80.     ("metsbi"        . variable-large-bold-italic)
  81.     ("metsi"        . variable-large-italic)
  82.     ("cmr5"        . variable)
  83.     ("cmr10"        . variable)
  84.     ("cmr18"        . variable)
  85.     ("cmold"        . variable)
  86.     ("cmdunh"        . variable)
  87.     ("hl10"        . variable)
  88.     ("hl10b"        . variable-bold)
  89.     ("hl12"        . variable)
  90.     ("hl12b"        . variable-bold)
  91.     ("hl12bi"        . variable-bold-italic)
  92.     ("hl12i"        . variable-italic)
  93.     ("hl6"        . variable)
  94.     ("hl7"        . variable)
  95.     ("tr10"        . variable)
  96.     ("tr10b"        . variable-bold)
  97.     ("tr10bi"        . variable-bold-italic)
  98.     ("tr10i"        . variable-italic)
  99.     ("tr12"        . variable)
  100.     ("tr12b"        . variable-bold)
  101.     ("tr12bi"        . variable-bold-italic)
  102.     ("tr12i"        . variable-italic)
  103.     ("tr18"        . variable-large)
  104.     ("tr18b"        . variable-large-bold)
  105.     ("tr8"        . variable)
  106.     ("tr8b"        . variable-bold)
  107.     ("tr8i"        . variable-italic)
  108.     ("5x5"        . small)
  109.     ("tiny"        . small)
  110.     ("43vxms"        . variable-large)
  111.     ("courier"        . bold)
  112.     ("adobe-courier10"    . default)
  113.     ("adobe-courier14"    . bold)
  114.     ("adobe-courier10b"    . bold)
  115.     ("adobe-courier14b"    . bold)
  116.     ("adobe-hl12"    . variable)
  117.     ("adobe-hl14"    . variable)
  118.     ("adobe-hl14b"    . variable-bold)
  119.     )
  120.   "Alist of LISPM font names to Emacs face names.")
  121.  
  122.  
  123. (defun lispm-font-to-face (lispm-font)
  124.   (if (symbolp lispm-font)
  125.       (setq lispm-font (symbol-name lispm-font)))
  126.   (let ((case-fold-search t)
  127.     face)
  128.     (setq lispm-font (downcase lispm-font))
  129.     (if (string-match "^fonts:+" lispm-font)
  130.     (setq lispm-font (substring lispm-font (match-end 0))))
  131.     (if (setq face (cdr (assoc lispm-font lispm-font-to-face)))
  132.     (if (find-face face)
  133.         face
  134.       (message "warning: unknown face %s" face)
  135.       'default)
  136.       (message "warning: unknown Lispm font %s" (upcase lispm-font))
  137.       'default)))
  138.  
  139. (defvar fonts)  ; the -*- line of the file will set this.
  140.  
  141. (defun lispm-fontify-hack-local-variables ()
  142.   ;; Sometimes code has font-shifts in the -*- line, which means that the
  143.   ;; local variables will have been read incorrectly by the emacs-lisp reader.
  144.   ;; In particular, the `fonts' variable might be corrupted.  So if there
  145.   ;; are font-shifts in the prop line, re-parse it.
  146.   (if (or (not (boundp 'fonts))
  147.       (null 'fonts)
  148.       (let ((case-fold-search t))
  149.         (and (looking-at "[ \t]*;.*-\\*-.*fonts[ \t]*:.*-\\*-")
  150.          (looking-at ".*\^F"))))
  151.       (save-excursion
  152.     (save-restriction
  153.       (end-of-line)
  154.       (narrow-to-region (point-min) (point))
  155.       (goto-char (point-min))
  156.       (while (re-search-forward "\^F[0-9a-zA-Z*]" nil t)
  157.         (delete-region (match-beginning 0) (match-end 0)))
  158.       (let ((enable-local-variables 'query))
  159.         (hack-local-variables))))))
  160.  
  161. (defun lispm-fontify-buffer ()
  162.   (save-excursion
  163.     (goto-char (point-min))
  164.     (if (fboundp 'font-lock-mode) (font-lock-mode 0))
  165.     (lispm-fontify-hack-local-variables)
  166.     (let ((font-stack nil)
  167.       (p (point))
  168.       c)
  169.       (while (search-forward "\^F" nil t)
  170.     (delete-char -1)
  171.     (setq c (following-char))
  172.     (delete-char 1)
  173.     (cond ((= c ?\^F)
  174.            (insert "\^F"))
  175.           ((= c ?*)
  176.            (if (and font-stack (/= p (point)))
  177.            (set-extent-face (make-extent p (point)) (car font-stack)))
  178.            (setq p (point))
  179.            (setq font-stack (cdr font-stack)))
  180.           ((or (< c ?0) (> c ?Z)) ; error...
  181.            nil)
  182.           ((>= (setq c (- c ?0)) (length fonts)) ; error...
  183.            nil)
  184.           (t
  185.            (if (and font-stack (/= p (point)))
  186.            (set-extent-face (make-extent p (point)) (car font-stack)))
  187.            (setq font-stack (cons (lispm-font-to-face (nth c fonts))
  188.                       font-stack))
  189.            (setq p (point)))))
  190.       (if (and font-stack (/= p (point)))
  191.       (set-extent-face (make-extent p (point)) (car font-stack))))))
  192.